home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / gnus-topic.el.z / gnus-topic.el
Encoding:
Text File  |  1998-05-21  |  46.7 KB  |  1,411 lines
  1. ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
  2. ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Ilja Weis <kult@uni-paderborn.de>
  5. ;;    Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  6. ;; Keywords: news
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;;; Code:
  28.  
  29. (eval-when-compile (require 'cl))
  30.  
  31. (require 'gnus)
  32. (require 'gnus-group)
  33. (require 'gnus-start)
  34.  
  35. (defgroup gnus-topic nil
  36.   "Group topics."
  37.   :group 'gnus-group)
  38.  
  39. (defvar gnus-topic-mode nil
  40.   "Minor mode for Gnus group buffers.")
  41.  
  42. (defcustom gnus-topic-mode-hook nil
  43.   "Hook run in topic mode buffers."
  44.   :type 'hook
  45.   :group 'gnus-topic)
  46.  
  47. (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
  48.   "Format of topic lines.
  49. It works along the same lines as a normal formatting string,
  50. with some simple extensions.
  51.  
  52. %i  Indentation based on topic level.
  53. %n  Topic name.
  54. %v  Nothing if the topic is visible, \"...\" otherwise.
  55. %g  Number of groups in the topic.
  56. %a  Number of unread articles in the groups in the topic.
  57. %A  Number of unread articles in the groups in the topic and its subtopics.
  58. "
  59.   :type 'string
  60.   :group 'gnus-topic)
  61.  
  62. (defcustom gnus-topic-indent-level 2
  63.   "*How much each subtopic should be indented."
  64.   :type 'integer
  65.   :group 'gnus-topic)
  66.  
  67. (defcustom gnus-topic-display-empty-topics t
  68.   "*If non-nil, display the topic lines even of topics that have no unread articles."
  69.   :type 'boolean
  70.   :group 'gnus-topic)
  71.  
  72. ;; Internal variables.
  73.  
  74. (defvar gnus-topic-active-topology nil)
  75. (defvar gnus-topic-active-alist nil)
  76.  
  77. (defvar gnus-topology-checked-p nil
  78.   "Whether the topology has been checked in this session.")
  79.  
  80. (defvar gnus-topic-killed-topics nil)
  81. (defvar gnus-topic-inhibit-change-level nil)
  82.  
  83. (defconst gnus-topic-line-format-alist
  84.   `((?n name ?s)
  85.     (?v visible ?s)
  86.     (?i indentation ?s)
  87.     (?g number-of-groups ?d)
  88.     (?a (gnus-topic-articles-in-topic entries) ?d)
  89.     (?A total-number-of-articles ?d)
  90.     (?l level ?d)))
  91.  
  92. (defvar gnus-topic-line-format-spec nil)
  93.  
  94. ;;; Utility functions
  95.  
  96. (defun gnus-group-topic-name ()
  97.   "The name of the topic on the current line."
  98.   (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic)))
  99.     (and topic (symbol-name topic))))
  100.  
  101. (defun gnus-group-topic-level ()
  102.   "The level of the topic on the current line."
  103.   (get-text-property (gnus-point-at-bol) 'gnus-topic-level))
  104.  
  105. (defun gnus-group-topic-unread ()
  106.   "The number of unread articles in topic on the current line."
  107.   (get-text-property (gnus-point-at-bol) 'gnus-topic-unread))
  108.  
  109. (defun gnus-topic-unread (topic)
  110.   "Return the number of unread articles in TOPIC."
  111.   (or (save-excursion
  112.     (and (gnus-topic-goto-topic topic)
  113.          (gnus-group-topic-unread)))
  114.       0))
  115.  
  116. (defun gnus-group-topic-p ()
  117.   "Return non-nil if the current line is a topic."
  118.   (gnus-group-topic-name))
  119.  
  120. (defun gnus-topic-visible-p ()
  121.   "Return non-nil if the current topic is visible."
  122.   (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
  123.  
  124. (defun gnus-topic-articles-in-topic (entries)
  125.   (let ((total 0)
  126.     number)
  127.     (while entries
  128.       (when (numberp (setq number (car (pop entries))))
  129.     (incf total number)))
  130.     total))
  131.  
  132. (defun gnus-group-topic (group)
  133.   "Return the topic GROUP is a member of."
  134.   (let ((alist gnus-topic-alist)
  135.     out)
  136.     (while alist
  137.       (when (member group (cdar alist))
  138.     (setq out (caar alist)
  139.           alist nil))
  140.       (setq alist (cdr alist)))
  141.     out))
  142.  
  143. (defun gnus-group-parent-topic (group)
  144.   "Return the topic GROUP is member of by looking at the group buffer."
  145.   (save-excursion
  146.     (set-buffer gnus-group-buffer)
  147.     (if (gnus-group-goto-group group)
  148.     (gnus-current-topic)
  149.       (gnus-group-topic group))))
  150.  
  151. (defun gnus-topic-goto-topic (topic)
  152.   "Go to TOPIC."
  153.   (when topic
  154.     (gnus-goto-char (text-property-any (point-min) (point-max)
  155.                        'gnus-topic (intern topic)))))
  156.  
  157. (defun gnus-current-topic ()
  158.   "Return the name of the current topic."
  159.   (let ((result
  160.      (or (get-text-property (point) 'gnus-topic)
  161.          (save-excursion
  162.            (and (gnus-goto-char (previous-single-property-change
  163.                      (point) 'gnus-topic))
  164.             (get-text-property (max (1- (point)) (point-min))
  165.                        'gnus-topic))))))
  166.     (when result
  167.       (symbol-name result))))
  168.  
  169. (defun gnus-current-topics ()
  170.   "Return a list of all current topics, lowest in hierarchy first."
  171.   (let ((topic (gnus-current-topic))
  172.     topics)
  173.     (while topic
  174.       (push topic topics)
  175.       (setq topic (gnus-topic-parent-topic topic)))
  176.     (nreverse topics)))
  177.  
  178. (defun gnus-group-active-topic-p ()
  179.   "Say whether the current topic comes from the active topics."
  180.   (save-excursion
  181.     (beginning-of-line)
  182.     (get-text-property (point) 'gnus-active)))
  183.  
  184. (defun gnus-topic-find-groups (topic &optional level all)
  185.   "Return entries for all visible groups in TOPIC."
  186.   (let ((groups (cdr (assoc topic gnus-topic-alist)))
  187.         info clevel unread group lowest params visible-groups entry active)
  188.     (setq lowest (or lowest 1))
  189.     (setq level (or level 7))
  190.     ;; We go through the newsrc to look for matches.
  191.     (while groups
  192.       (when (setq group (pop groups))
  193.     (setq entry (gnus-gethash group gnus-newsrc-hashtb)
  194.           info (nth 2 entry)
  195.           params (gnus-info-params info)
  196.           active (gnus-active group)
  197.           unread (or (car entry)
  198.              (and (not (equal group "dummy.group"))
  199.                   active
  200.                   (- (1+ (cdr active)) (car active))))
  201.           clevel (or (gnus-info-level info)
  202.              (if (member group gnus-zombie-list) 8 9))))
  203.       (and
  204.        unread                ; nil means that the group is dead.
  205.        (<= clevel level)
  206.        (>= clevel lowest)        ; Is inside the level we want.
  207.        (or all
  208.        (if (eq unread t)
  209.            gnus-group-list-inactive-groups
  210.          (> unread 0))
  211.        (and gnus-list-groups-with-ticked-articles
  212.         (cdr (assq 'tick (gnus-info-marks info))))
  213.                     ; Has right readedness.
  214.        ;; Check for permanent visibility.
  215.        (and gnus-permanently-visible-groups
  216.         (string-match gnus-permanently-visible-groups group))
  217.        (memq 'visible params)
  218.        (cdr (assq 'visible params)))
  219.        ;; Add this group to the list of visible groups.
  220.        (push (or entry group) visible-groups)))
  221.     (nreverse visible-groups)))
  222.  
  223. (defun gnus-topic-previous-topic (topic)
  224.   "Return the previous topic on the same level as TOPIC."
  225.   (let ((top (cddr (gnus-topic-find-topology
  226.             (gnus-topic-parent-topic topic)))))
  227.     (unless (equal topic (caaar top))
  228.       (while (and top (not (equal (caaadr top) topic)))
  229.     (setq top (cdr top)))
  230.       (caaar top))))
  231.  
  232. (defun gnus-topic-parent-topic (topic &optional topology)
  233.   "Return the parent of TOPIC."
  234.   (unless topology
  235.     (setq topology gnus-topic-topology))
  236.   (let ((parent (car (pop topology)))
  237.     result found)
  238.     (while (and topology
  239.         (not (setq found (equal (caaar topology) topic)))
  240.         (not (setq result (gnus-topic-parent-topic
  241.                    topic (car topology)))))
  242.       (setq topology (cdr topology)))
  243.     (or result (and found parent))))
  244.  
  245. (defun gnus-topic-next-topic (topic &optional previous)
  246.   "Return the next sibling of TOPIC."
  247.   (let ((parentt (cddr (gnus-topic-find-topology
  248.             (gnus-topic-parent-topic topic))))
  249.     prev)
  250.     (while (and parentt
  251.         (not (equal (caaar parentt) topic)))
  252.       (setq prev (caaar parentt)
  253.         parentt (cdr parentt)))
  254.     (if previous
  255.     prev
  256.       (caaadr parentt))))
  257.  
  258. (defun gnus-topic-forward-topic (num)
  259.   "Go to the next topic on the same level as the current one."
  260.   (let* ((topic (gnus-current-topic))
  261.      (way (if (< num 0) 'gnus-topic-previous-topic
  262.         'gnus-topic-next-topic))
  263.      (num (abs num)))
  264.     (while (and (not (zerop num))
  265.         (setq topic (funcall way topic)))
  266.       (when (gnus-topic-goto-topic topic)
  267.     (decf num)))
  268.     (unless (zerop num)
  269.       (goto-char (point-max)))
  270.     num))
  271.  
  272. (defun gnus-topic-find-topology (topic &optional topology level remove)
  273.   "Return the topology of TOPIC."
  274.   (unless topology
  275.     (setq topology gnus-topic-topology)
  276.     (setq level 0))
  277.   (let ((top topology)
  278.     result)
  279.     (if (equal (caar topology) topic)
  280.     (progn
  281.       (when remove
  282.         (delq topology remove))
  283.       (cons level topology))
  284.       (setq topology (cdr topology))
  285.       (while (and topology
  286.           (not (setq result (gnus-topic-find-topology
  287.                      topic (car topology) (1+ level)
  288.                      (and remove top)))))
  289.     (setq topology (cdr topology)))
  290.       result)))
  291.  
  292. (defvar gnus-tmp-topics nil)
  293. (defun gnus-topic-list (&optional topology)
  294.   "Return a list of all topics in the topology."
  295.   (unless topology
  296.     (setq topology gnus-topic-topology
  297.       gnus-tmp-topics nil))
  298.   (push (caar topology) gnus-tmp-topics)
  299.   (mapcar 'gnus-topic-list (cdr topology))
  300.   gnus-tmp-topics)
  301.  
  302. ;;; Topic parameter jazz
  303.  
  304. (defun gnus-topic-parameters (topic)
  305.   "Return the parameters for TOPIC."
  306.   (let ((top (gnus-topic-find-topology topic)))
  307.     (when top
  308.       (nth 3 (cadr top)))))
  309.  
  310. (defun gnus-topic-set-parameters (topic parameters)
  311.   "Set the topic parameters of TOPIC to PARAMETERS."
  312.   (let ((top (gnus-topic-find-topology topic)))
  313.     (unless top
  314.       (error "No such topic: %s" topic))
  315.     ;; We may have to extend if there is no parameters here
  316.     ;; to begin with.
  317.     (unless (nthcdr 2 (cadr top))
  318.       (nconc (cadr top) (list nil)))
  319.     (unless (nthcdr 3 (cadr top))
  320.       (nconc (cadr top) (list nil)))
  321.     (setcar (nthcdr 3 (cadr top)) parameters)
  322.     (gnus-dribble-enter
  323.      (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))
  324.  
  325. (defun gnus-group-topic-parameters (group)
  326.   "Compute the group parameters for GROUP taking into account inheritance from topics."
  327.   (let ((params-list (list (gnus-group-get-parameter group)))
  328.     topics params param out)
  329.     (save-excursion
  330.       (gnus-group-goto-group group)
  331.       (setq topics (gnus-current-topics))
  332.       (while topics
  333.     (push (gnus-topic-parameters (pop topics)) params-list))
  334.       ;; We probably have lots of nil elements here, so
  335.       ;; we remove them.  Probably faster than doing this "properly".
  336.       (setq params-list (delq nil params-list))
  337.       ;; Now we have all the parameters, so we go through them
  338.       ;; and do inheritance in the obvious way.
  339.       (while (setq params (pop params-list))
  340.     (while (setq param (pop params))
  341.       (when (atom param)
  342.         (setq param (cons param t)))
  343.       ;; Override any old versions of this param.
  344.       (setq out (delq (assq (car param) out) out))
  345.       (push param out)))
  346.       ;; Return the resulting parameter list.
  347.       out)))
  348.  
  349. ;;; General utility functions
  350.  
  351. (defun gnus-topic-enter-dribble ()
  352.   (gnus-dribble-enter
  353.    (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
  354.  
  355. ;;; Generating group buffers
  356.  
  357. (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level)
  358.   "List all newsgroups with unread articles of level LEVEL or lower, and
  359. use the `gnus-group-topics' to sort the groups.
  360. If ALL is non-nil, list groups that have no unread articles.
  361. If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
  362.   (set-buffer gnus-group-buffer)
  363.   (let ((buffer-read-only nil)
  364.         (lowest (or lowest 1)))
  365.  
  366.     (when (or (not gnus-topic-alist)
  367.           (not gnus-topology-checked-p))
  368.       (gnus-topic-check-topology))
  369.  
  370.     (unless list-topic
  371.       (erase-buffer))
  372.  
  373.     ;; List dead groups?
  374.     (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
  375.       (gnus-group-prepare-flat-list-dead
  376.        (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
  377.        gnus-level-zombie ?Z
  378.        regexp))
  379.  
  380.     (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
  381.       (gnus-group-prepare-flat-list-dead
  382.        (setq gnus-killed-list (sort gnus-killed-list 'string<))
  383.        gnus-level-killed ?K
  384.        regexp))
  385.  
  386.     ;; Use topics.
  387.     (prog1
  388.     (when (< lowest gnus-level-zombie)
  389.       (if list-topic
  390.           (let ((top (gnus-topic-find-topology list-topic)))
  391.         (gnus-topic-prepare-topic (cdr top) (car top)
  392.                       (or topic-level level) all))
  393.         (gnus-topic-prepare-topic gnus-topic-topology 0
  394.                       (or topic-level level) all)))
  395.  
  396.       (gnus-group-set-mode-line)
  397.       (setq gnus-group-list-mode (cons level all))
  398.       (run-hooks 'gnus-group-prepare-hook))))
  399.  
  400. (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent)
  401.   "Insert TOPIC into the group buffer.
  402. If SILENT, don't insert anything.  Return the number of unread
  403. articles in the topic and its subtopics."
  404.   (let* ((type (pop topicl))
  405.      (entries (gnus-topic-find-groups (car type) list-level all))
  406.      (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
  407.      (gnus-group-indentation
  408.       (make-string (* gnus-topic-indent-level level) ? ))
  409.      (beg (progn (beginning-of-line) (point)))
  410.      (topicl (reverse topicl))
  411.      (all-entries entries)
  412.      (point-max (point-max))
  413.      (unread 0)
  414.      (topic (car type))
  415.      info entry end active tick)
  416.     ;; Insert any sub-topics.
  417.     (while topicl
  418.       (incf unread
  419.         (gnus-topic-prepare-topic
  420.          (pop topicl) (1+ level) list-level all
  421.          (not visiblep))))
  422.     (setq end (point))
  423.     (goto-char beg)
  424.     ;; Insert all the groups that belong in this topic.
  425.     (while (setq entry (pop entries))
  426.       (when visiblep
  427.     (if (stringp entry)
  428.         ;; Dead groups.
  429.         (gnus-group-insert-group-line
  430.          entry (if (member entry gnus-zombie-list) 8 9)
  431.          nil (- (1+ (cdr (setq active (gnus-active entry))))
  432.             (car active))
  433.          nil)
  434.       ;; Living groups.
  435.       (when (setq info (nth 2 entry))
  436.         (gnus-group-insert-group-line
  437.          (gnus-info-group info)
  438.          (gnus-info-level info) (gnus-info-marks info)
  439.          (car entry) (gnus-info-method info)))))
  440.       (when (and (listp entry)
  441.          (numberp (car entry)))
  442.     (incf unread (car entry)))
  443.       (when (listp entry)
  444.     (setq tick t)))
  445.     (goto-char beg)
  446.     ;; Insert the topic line.
  447.     (when (and (not silent)
  448.            (or gnus-topic-display-empty-topics ;We want empty topics
  449.            (not (zerop unread))    ;Non-empty
  450.            tick            ;Ticked articles
  451.            (/= point-max (point-max)))) ;Unactivated groups
  452.       (gnus-extent-start-open (point))
  453.       (gnus-topic-insert-topic-line
  454.        (car type) visiblep
  455.        (not (eq (nth 2 type) 'hidden))
  456.        level all-entries unread))
  457.     (goto-char end)
  458.     unread))
  459.  
  460. (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
  461.   "Remove the current topic."
  462.   (let ((topic (gnus-group-topic-name))
  463.     (level (gnus-group-topic-level))
  464.     (beg (progn (beginning-of-line) (point)))
  465.     buffer-read-only)
  466.     (when topic
  467.       (while (and (zerop (forward-line 1))
  468.           (> (or (gnus-group-topic-level) (1+ level)) level)))
  469.       (delete-region beg (point))
  470.       ;; Do the change in this rather odd manner because it has been
  471.       ;; reported that some topics share parts of some lists, for some
  472.       ;; reason.  I have been unable to determine why this is the
  473.       ;; case, but this hack seems to take care of things.
  474.       (let ((data (cadr (gnus-topic-find-topology topic))))
  475.     (setcdr data
  476.         (list (if insert 'visible 'invisible)
  477.               (if hide 'hide nil)
  478.               (cadddr data))))
  479.       (if total-remove
  480.       (setq gnus-topic-alist
  481.         (delq (assoc topic gnus-topic-alist) gnus-topic-alist))
  482.     (gnus-topic-insert-topic topic in-level)))))
  483.  
  484. (defun gnus-topic-insert-topic (topic &optional level)
  485.   "Insert TOPIC."
  486.   (gnus-group-prepare-topics
  487.    (car gnus-group-list-mode) (cdr gnus-group-list-mode)
  488.    nil nil topic level))
  489.  
  490. (defun gnus-topic-fold (&optional insert)
  491.   "Remove/insert the current topic."
  492.   (let ((topic (gnus-group-topic-name)))
  493.     (when topic
  494.       (save-excursion
  495.     (if (not (gnus-group-active-topic-p))
  496.         (gnus-topic-remove-topic
  497.          (or insert (not (gnus-topic-visible-p))))
  498.       (let ((gnus-topic-topology gnus-topic-active-topology)
  499.         (gnus-topic-alist gnus-topic-active-alist)
  500.         (gnus-group-list-mode (cons 5 t)))
  501.         (gnus-topic-remove-topic
  502.          (or insert (not (gnus-topic-visible-p))) nil nil 9)
  503.         (gnus-topic-enter-dribble)))))))
  504.  
  505. (defun gnus-topic-insert-topic-line (name visiblep shownp level entries
  506.                       &optional unread)
  507.   (let* ((visible (if visiblep "" "..."))
  508.      (indentation (make-string (* gnus-topic-indent-level level) ? ))
  509.      (total-number-of-articles unread)
  510.      (number-of-groups (length entries))
  511.      (active-topic (eq gnus-topic-alist gnus-topic-active-alist)))
  512.     (beginning-of-line)
  513.     ;; Insert the text.
  514.     (gnus-add-text-properties
  515.      (point)
  516.      (prog1 (1+ (point))
  517.        (eval gnus-topic-line-format-spec))
  518.      (list 'gnus-topic (intern name)
  519.        'gnus-topic-level level
  520.        'gnus-topic-unread unread
  521.        'gnus-active active-topic
  522.        'gnus-topic-visible visiblep))))
  523.  
  524. (defun gnus-topic-update-topics-containing-group (group)
  525.   "Update all topics that have GROUP as a member."
  526.   (when (and (eq major-mode 'gnus-group-mode)
  527.          gnus-topic-mode)
  528.     (save-excursion
  529.       (let ((alist gnus-topic-alist))
  530.     ;; This is probably not entirely correct.  If a topic
  531.     ;; isn't shown, then it's not updated.  But the updating
  532.     ;; should be performed in any case, since the topic's
  533.     ;; parent should be updated.  Pfft.
  534.     (while alist
  535.       (when (and (member group (cdar alist))
  536.              (gnus-topic-goto-topic (caar alist)))
  537.         (gnus-topic-update-topic-line (caar alist)))
  538.       (pop alist))))))
  539.  
  540. (defun gnus-topic-update-topic ()
  541.   "Update all parent topics to the current group."
  542.   (when (and (eq major-mode 'gnus-group-mode)
  543.          gnus-topic-mode)
  544.     (let ((group (gnus-group-group-name))
  545.           (m (point-marker))
  546.       (buffer-read-only nil))
  547.       (when (and group
  548.          (gnus-get-info group)
  549.          (gnus-topic-goto-topic (gnus-current-topic)))
  550.     (gnus-topic-update-topic-line (gnus-group-topic-name))
  551.     (goto-char m)
  552.     (set-marker m nil)
  553.     (gnus-group-position-point)))))
  554.  
  555. (defun gnus-topic-goto-missing-group (group)
  556.   "Place point where GROUP is supposed to be inserted."
  557.   (let* ((topic (gnus-group-topic group))
  558.      (groups (cdr (assoc topic gnus-topic-alist)))
  559.      (g (cdr (member group groups)))
  560.      (unfound t))
  561.     ;; Try to jump to a visible group.
  562.     (while (and g (not (gnus-group-goto-group (car g) t)))
  563.       (pop g))
  564.     ;; It wasn't visible, so we try to see where to insert it.
  565.     (when (not g)
  566.       (setq g (cdr (member group (reverse groups))))
  567.       (while (and g unfound)
  568.     (when (gnus-group-goto-group (pop g) t)
  569.       (forward-line 1)
  570.       (setq unfound nil)))
  571.       (when (and unfound
  572.          topic
  573.          (not (gnus-topic-goto-missing-topic topic)))
  574.     (gnus-topic-insert-topic-line
  575.      topic t t (car (gnus-topic-find-topology topic)) nil 0)))))
  576.  
  577. (defun gnus-topic-goto-missing-topic (topic)
  578.   (if (gnus-topic-goto-topic topic)
  579.       (forward-line 1)
  580.     ;; Topic not displayed.
  581.     (let* ((top (gnus-topic-find-topology
  582.          (gnus-topic-parent-topic topic)))
  583.        (tp (reverse (cddr top))))
  584.       (while (not (equal (caaar tp) topic))
  585.     (setq tp (cdr tp)))
  586.       (pop tp)
  587.       (while (and tp
  588.           (not (gnus-topic-goto-topic (caaar tp))))
  589.     (pop tp))
  590.       (if tp
  591.       (gnus-topic-forward-topic 1)
  592.     (gnus-topic-goto-missing-topic (caadr top))))
  593.     nil))
  594.  
  595. (defun gnus-topic-update-topic-line (topic-name &optional reads)
  596.   (let* ((top (gnus-topic-find-topology topic-name))
  597.      (type (cadr top))
  598.      (children (cddr top))
  599.      (entries (gnus-topic-find-groups
  600.            (car type) (car gnus-group-list-mode)
  601.            (cdr gnus-group-list-mode)))
  602.      (parent (gnus-topic-parent-topic topic-name))
  603.      (all-entries entries)
  604.      (unread 0)
  605.      old-unread entry)
  606.     (when (gnus-topic-goto-topic (car type))
  607.       ;; Tally all the groups that belong in this topic.
  608.       (if reads
  609.       (setq unread (- (gnus-group-topic-unread) reads))
  610.     (while children
  611.       (incf unread (gnus-topic-unread (caar (pop children)))))
  612.     (while (setq entry (pop entries))
  613.       (when (numberp (car entry))
  614.         (incf unread (car entry)))))
  615.       (setq old-unread (gnus-group-topic-unread))
  616.       ;; Insert the topic line.
  617.       (gnus-topic-insert-topic-line
  618.        (car type) (gnus-topic-visible-p)
  619.        (not (eq (nth 2 type) 'hidden))
  620.        (gnus-group-topic-level) all-entries unread)
  621.       (gnus-delete-line))
  622.     (when parent
  623.       (forward-line -1)
  624.       (gnus-topic-update-topic-line
  625.        parent (- old-unread (gnus-group-topic-unread))))
  626.     unread))
  627.  
  628. (defun gnus-topic-group-indentation ()
  629.   (make-string
  630.    (* gnus-topic-indent-level
  631.       (or (save-excursion
  632.         (forward-line -1)
  633.         (gnus-topic-goto-topic (gnus-current-topic))
  634.         (gnus-group-topic-level))
  635.       0))
  636.    ? ))
  637.  
  638. ;;; Initialization
  639.  
  640. (gnus-add-shutdown 'gnus-topic-close 'gnus)
  641.  
  642. (defun gnus-topic-close ()
  643.   (setq gnus-topic-active-topology nil
  644.     gnus-topic-active-alist nil
  645.     gnus-topic-killed-topics nil
  646.     gnus-topology-checked-p nil))
  647.  
  648. (defun gnus-topic-check-topology ()
  649.   ;; The first time we set the topology to whatever we have
  650.   ;; gotten here, which can be rather random.
  651.   (unless gnus-topic-alist
  652.     (gnus-topic-init-alist))
  653.  
  654.   (setq gnus-topology-checked-p t)
  655.   ;; Go through the topic alist and make sure that all topics
  656.   ;; are in the topic topology.
  657.   (let ((topics (gnus-topic-list))
  658.     (alist gnus-topic-alist)
  659.     changed)
  660.     (while alist
  661.       (unless (member (caar alist) topics)
  662.     (nconc gnus-topic-topology
  663.            (list (list (list (caar alist) 'visible))))
  664.     (setq changed t))
  665.       (setq alist (cdr alist)))
  666.     (when changed
  667.       (gnus-topic-enter-dribble))
  668.     ;; Conversely, go through the topology and make sure that all
  669.     ;; topologies have alists.
  670.     (while topics
  671.       (unless (assoc (car topics) gnus-topic-alist)
  672.     (push (list (car topics)) gnus-topic-alist))
  673.       (pop topics)))
  674.   ;; Go through all living groups and make sure that
  675.   ;; they belong to some topic.
  676.   (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
  677.                      gnus-topic-alist)))
  678.      (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
  679.      (newsrc (cdr gnus-newsrc-alist))
  680.      group)
  681.     (while newsrc
  682.       (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
  683.     (setcdr entry (list group))
  684.     (setq entry (cdr entry)))))
  685.   ;; Go through all topics and make sure they contain only living groups.
  686.   (let ((alist gnus-topic-alist)
  687.     topic)
  688.     (while (setq topic (pop alist))
  689.       (while (cdr topic)
  690.     (if (and (cadr topic)
  691.          (gnus-gethash (cadr topic) gnus-newsrc-hashtb))
  692.         (setq topic (cdr topic))
  693.       (setcdr topic (cddr topic)))))))
  694.  
  695. (defun gnus-topic-init-alist ()
  696.   "Initialize the topic structures."
  697.   (setq gnus-topic-topology
  698.     (cons (list "Gnus" 'visible)
  699.           (mapcar (lambda (topic)
  700.             (list (list (car topic) 'visible)))
  701.               '(("misc")))))
  702.   (setq gnus-topic-alist
  703.     (list (cons "misc"
  704.             (mapcar (lambda (info) (gnus-info-group info))
  705.                 (cdr gnus-newsrc-alist)))
  706.           (list "Gnus")))
  707.   (gnus-topic-enter-dribble))
  708.  
  709. ;;; Maintenance
  710.  
  711. (defun gnus-topic-clean-alist ()
  712.   "Remove bogus groups from the topic alist."
  713.   (let ((topic-alist gnus-topic-alist)
  714.     result topic)
  715.     (unless gnus-killed-hashtb
  716.       (gnus-make-hashtable-from-killed))
  717.     (while (setq topic (pop topic-alist))
  718.       (let ((topic-name (pop topic))
  719.         group filtered-topic)
  720.     (while (setq group (pop topic))
  721.       (when (and (or (gnus-gethash group gnus-active-hashtb)
  722.              (gnus-info-method (gnus-get-info group)))
  723.              (not (gnus-gethash group gnus-killed-hashtb)))
  724.         (push group filtered-topic)))
  725.     (push (cons topic-name (nreverse filtered-topic)) result)))
  726.     (setq gnus-topic-alist (nreverse result))))
  727.  
  728. (defun gnus-topic-change-level (group level oldlevel &optional previous)
  729.   "Run when changing levels to enter/remove groups from topics."
  730.   (save-excursion
  731.     (set-buffer gnus-group-buffer)
  732.     (gnus-group-goto-group (or (car (nth 2 previous)) group))
  733.     (when (and gnus-topic-mode
  734.            gnus-topic-alist
  735.            (not gnus-topic-inhibit-change-level))
  736.       ;; Remove the group from the topics.
  737.       (when (and (< oldlevel gnus-level-zombie)
  738.          (>= level gnus-level-zombie))
  739.     (let (alist)
  740.       (forward-line -1)
  741.       (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist))
  742.         (setcdr alist (gnus-delete-first group (cdr alist))))))
  743.       ;; If the group is subscribed we enter it into the topics.
  744.       (when (and (< level gnus-level-zombie)
  745.          (>= oldlevel gnus-level-zombie))
  746.     (let* ((prev (gnus-group-group-name))
  747.            (gnus-topic-inhibit-change-level t)
  748.            (gnus-group-indentation
  749.         (make-string
  750.          (* gnus-topic-indent-level
  751.             (or (save-excursion
  752.               (gnus-topic-goto-topic (gnus-current-topic))
  753.               (gnus-group-topic-level))
  754.             0))
  755.          ? ))
  756.            (yanked (list group))
  757.            alist talist end)
  758.       ;; Then we enter the yanked groups into the topics they belong
  759.       ;; to.
  760.       (when (setq alist (assoc (save-excursion
  761.                      (forward-line -1)
  762.                      (or
  763.                       (gnus-current-topic)
  764.                       (caar gnus-topic-topology)))
  765.                    gnus-topic-alist))
  766.         (setq talist alist)
  767.         (when (stringp yanked)
  768.           (setq yanked (list yanked)))
  769.         (if (not prev)
  770.         (nconc alist yanked)
  771.           (if (not (cdr alist))
  772.           (setcdr alist (nconc yanked (cdr alist)))
  773.         (while (and (not end) (cdr alist))
  774.           (when (equal (cadr alist) prev)
  775.             (setcdr alist (nconc yanked (cdr alist)))
  776.             (setq end t))
  777.           (setq alist (cdr alist)))
  778.         (unless end
  779.           (nconc talist yanked))))))
  780.     (gnus-topic-update-topic)))))
  781.  
  782. (defun gnus-topic-goto-next-group (group props)
  783.   "Go to group or the next group after group."
  784.   (if (not group)
  785.       (if (not (memq 'gnus-topic props))
  786.       (goto-char (point-max))
  787.     (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))))
  788.     (if (gnus-group-goto-group group)
  789.     t
  790.       ;; The group is no longer visible.
  791.       (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist))
  792.          (after (cdr (member group (cdr list)))))
  793.     ;; First try to put point on a group after the current one.
  794.     (while (and after
  795.             (not (gnus-group-goto-group (car after))))
  796.       (setq after (cdr after)))
  797.     ;; Then try to put point on a group before point.
  798.     (unless after
  799.       (setq after (cdr (member group (reverse (cdr list)))))
  800.       (while (and after
  801.               (not (gnus-group-goto-group (car after))))
  802.         (setq after (cdr after))))
  803.     ;; Finally, just put point on the topic.
  804.     (if (not (car list))
  805.         (goto-char (point-min))
  806.       (unless after
  807.         (gnus-topic-goto-topic (car list))
  808.         (setq after nil)))
  809.     t))))
  810.  
  811. ;;; Topic-active functions
  812.  
  813. (defun gnus-topic-grok-active (&optional force)
  814.   "Parse all active groups and create topic structures for them."
  815.   ;; First we make sure that we have really read the active file.
  816.   (when (or force
  817.         (not gnus-topic-active-alist))
  818.     (let (groups)
  819.       ;; Get a list of all groups available.
  820.       (mapatoms (lambda (g) (when (symbol-value g)
  821.                   (push (symbol-name g) groups)))
  822.         gnus-active-hashtb)
  823.       (setq groups (sort groups 'string<))
  824.       ;; Init the variables.
  825.       (setq gnus-topic-active-topology (list (list "" 'visible)))
  826.       (setq gnus-topic-active-alist nil)
  827.       ;; Descend the top-level hierarchy.
  828.       (gnus-topic-grok-active-1 gnus-topic-active-topology groups)
  829.       ;; Set the top-level topic names to something nice.
  830.       (setcar (car gnus-topic-active-topology) "Gnus active")
  831.       (setcar (car gnus-topic-active-alist) "Gnus active"))))
  832.  
  833. (defun gnus-topic-grok-active-1 (topology groups)
  834.   (let* ((name (caar topology))
  835.      (prefix (concat "^" (regexp-quote name)))
  836.      tgroups ntopology group)
  837.     (while (and groups
  838.         (string-match prefix (setq group (car groups))))
  839.       (if (not (string-match "\\." group (match-end 0)))
  840.       ;; There are no further hierarchies here, so we just
  841.       ;; enter this group into the list belonging to this
  842.       ;; topic.
  843.       (push (pop groups) tgroups)
  844.     ;; New sub-hierarchy, so we add it to the topology.
  845.     (nconc topology (list (setq ntopology
  846.                     (list (list (substring
  847.                          group 0 (match-end 0))
  848.                         'invisible)))))
  849.     ;; Descend the hierarchy.
  850.     (setq groups (gnus-topic-grok-active-1 ntopology groups))))
  851.     ;; We remove the trailing "." from the topic name.
  852.     (setq name
  853.       (if (string-match "\\.$" name)
  854.           (substring name 0 (match-beginning 0))
  855.         name))
  856.     ;; Add this topic and its groups to the topic alist.
  857.     (push (cons name (nreverse tgroups)) gnus-topic-active-alist)
  858.     (setcar (car topology) name)
  859.     ;; We return the rest of the groups that didn't belong
  860.     ;; to this topic.
  861.     groups))
  862.  
  863. ;;; Topic mode, commands and keymap.
  864.  
  865. (defvar gnus-topic-mode-map nil)
  866. (defvar gnus-group-topic-map nil)
  867.  
  868. (unless gnus-topic-mode-map
  869.   (setq gnus-topic-mode-map (make-sparse-keymap))
  870.  
  871.   ;; Override certain group mode keys.
  872.   (gnus-define-keys gnus-topic-mode-map
  873.     "=" gnus-topic-select-group
  874.     "\r" gnus-topic-select-group
  875.     " " gnus-topic-read-group
  876.     "\C-k" gnus-topic-kill-group
  877.     "\C-y" gnus-topic-yank-group
  878.     "\M-g" gnus-topic-get-new-news-this-topic
  879.     "AT" gnus-topic-list-active
  880.     "Gp" gnus-topic-edit-parameters
  881.     "#" gnus-topic-mark-topic
  882.     "\M-#" gnus-topic-unmark-topic
  883.     gnus-mouse-2 gnus-mouse-pick-topic)
  884.  
  885.   ;; Define a new submap.
  886.   (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map)
  887.     "#" gnus-topic-mark-topic
  888.     "\M-#" gnus-topic-unmark-topic
  889.     "n" gnus-topic-create-topic
  890.     "m" gnus-topic-move-group
  891.     "D" gnus-topic-remove-group
  892.     "c" gnus-topic-copy-group
  893.     "h" gnus-topic-hide-topic
  894.     "s" gnus-topic-show-topic
  895.     "M" gnus-topic-move-matching
  896.     "C" gnus-topic-copy-matching
  897.     "\C-i" gnus-topic-indent
  898.     [tab] gnus-topic-indent
  899.     "r" gnus-topic-rename
  900.     "\177" gnus-topic-delete
  901.     [delete] gnus-topic-delete
  902.     "h" gnus-topic-toggle-display-empty-topics)
  903.  
  904.   (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
  905.     "s" gnus-topic-sort-groups
  906.     "a" gnus-topic-sort-groups-by-alphabet
  907.     "u" gnus-topic-sort-groups-by-unread
  908.     "l" gnus-topic-sort-groups-by-level
  909.     "v" gnus-topic-sort-groups-by-score
  910.     "r" gnus-topic-sort-groups-by-rank
  911.     "m" gnus-topic-sort-groups-by-method))
  912.  
  913. (defun gnus-topic-make-menu-bar ()
  914.   (unless (boundp 'gnus-topic-menu)
  915.     (easy-menu-define
  916.      gnus-topic-menu gnus-topic-mode-map ""
  917.      '("Topics"
  918.        ["Toggle topics" gnus-topic-mode t]
  919.        ("Groups"
  920.     ["Copy" gnus-topic-copy-group t]
  921.     ["Move" gnus-topic-move-group t]
  922.     ["Remove" gnus-topic-remove-group t]
  923.     ["Copy matching" gnus-topic-copy-matching t]
  924.     ["Move matching" gnus-topic-move-matching t])
  925.        ("Topics"
  926.     ["Show" gnus-topic-show-topic t]
  927.     ["Hide" gnus-topic-hide-topic t]
  928.     ["Delete" gnus-topic-delete t]
  929.     ["Rename" gnus-topic-rename t]
  930.     ["Create" gnus-topic-create-topic t]
  931.     ["Mark" gnus-topic-mark-topic t]
  932.     ["Indent" gnus-topic-indent t]
  933.     ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
  934.     ["Edit parameters" gnus-topic-edit-parameters t])
  935.        ["List active" gnus-topic-list-active t]))))
  936.  
  937. (defun gnus-topic-mode (&optional arg redisplay)
  938.   "Minor mode for topicsifying Gnus group buffers."
  939.   (interactive (list current-prefix-arg t))
  940.   (when (eq major-mode 'gnus-group-mode)
  941.     (make-local-variable 'gnus-topic-mode)
  942.     (setq gnus-topic-mode
  943.       (if (null arg) (not gnus-topic-mode)
  944.         (> (prefix-numeric-value arg) 0)))
  945.     ;; Infest Gnus with topics.
  946.     (if (not gnus-topic-mode)
  947.     (setq gnus-goto-missing-group-function nil)
  948.       (when (gnus-visual-p 'topic-menu 'menu)
  949.     (gnus-topic-make-menu-bar))
  950.       (setq gnus-topic-line-format-spec
  951.         (gnus-parse-format gnus-topic-line-format
  952.                    gnus-topic-line-format-alist t))
  953.       (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
  954.       (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
  955.       (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
  956.       (set (make-local-variable 'gnus-group-prepare-function)
  957.        'gnus-group-prepare-topics)
  958.       (set (make-local-variable 'gnus-group-get-parameter-function)
  959.        'gnus-group-topic-parameters)
  960.       (set (make-local-variable 'gnus-group-goto-next-group-function)
  961.        'gnus-topic-goto-next-group)
  962.       (set (make-local-variable 'gnus-group-indentation-function)
  963.        'gnus-topic-group-indentation)
  964.       (set (make-local-variable 'gnus-group-update-group-function)
  965.        'gnus-topic-update-topics-containing-group)
  966.       (set (make-local-variable 'gnus-group-sort-alist-function)
  967.        'gnus-group-sort-topic)
  968.       (setq gnus-group-change-level-function 'gnus-topic-change-level)
  969.       (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group)
  970.       (make-local-hook 'gnus-check-bogus-groups-hook)
  971.       (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
  972.       (setq gnus-topology-checked-p nil)
  973.       ;; We check the topology.
  974.       (when gnus-newsrc-alist
  975.     (gnus-topic-check-topology))
  976.       (run-hooks 'gnus-topic-mode-hook))
  977.     ;; Remove topic infestation.
  978.     (unless gnus-topic-mode
  979.       (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
  980.       (remove-hook 'gnus-group-change-level-function
  981.            'gnus-topic-change-level)
  982.       (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
  983.       (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
  984.       (setq gnus-group-sort-alist-function 'gnus-group-sort-flat))
  985.     (when redisplay
  986.       (gnus-group-list-groups))))
  987.  
  988. (defun gnus-topic-select-group (&optional all)
  989.   "Select this newsgroup.
  990. No article is selected automatically.
  991. If ALL is non-nil, already read articles become readable.
  992. If ALL is a number, fetch this number of articles.
  993.  
  994. If performed over a topic line, toggle folding the topic."
  995.   (interactive "P")
  996.   (if (gnus-group-topic-p)
  997.       (let ((gnus-group-list-mode
  998.          (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
  999.     (gnus-topic-fold all))
  1000.     (gnus-group-select-group all)))
  1001.  
  1002. (defun gnus-mouse-pick-topic (e)
  1003.   "Select the group or topic under the mouse pointer."
  1004.   (interactive "e")
  1005.   (mouse-set-point e)
  1006.   (gnus-topic-read-group nil))
  1007.  
  1008. (defun gnus-topic-read-group (&optional all no-article group)
  1009.   "Read news in this newsgroup.
  1010. If the prefix argument ALL is non-nil, already read articles become
  1011. readable.  IF ALL is a number, fetch this number of articles.  If the
  1012. optional argument NO-ARTICLE is non-nil, no article will be
  1013. auto-selected upon group entry.  If GROUP is non-nil, fetch that
  1014. group.
  1015.  
  1016. If performed over a topic line, toggle folding the topic."
  1017.   (interactive "P")
  1018.   (if (gnus-group-topic-p)
  1019.       (let ((gnus-group-list-mode
  1020.          (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
  1021.     (gnus-topic-fold all))
  1022.     (gnus-group-read-group all no-article group)))
  1023.  
  1024. (defun gnus-topic-create-topic (topic parent &optional previous full-topic)
  1025.   "Create a new TOPIC under PARENT.
  1026. When used interactively, PARENT will be the topic under point."
  1027.   (interactive
  1028.    (list
  1029.     (read-string "New topic: ")
  1030.     (gnus-current-topic)))
  1031.   ;; Check whether this topic already exists.
  1032.   (when (gnus-topic-find-topology topic)
  1033.     (error "Topic already exists"))
  1034.   (unless parent
  1035.     (setq parent (caar gnus-topic-topology)))
  1036.   (let ((top (cdr (gnus-topic-find-topology parent)))
  1037.     (full-topic (or full-topic `((,topic visible)))))
  1038.     (unless top
  1039.       (error "No such parent topic: %s" parent))
  1040.     (if previous
  1041.     (progn
  1042.       (while (and (cdr top)
  1043.               (not (equal (caaadr top) previous)))
  1044.         (setq top (cdr top)))
  1045.       (setcdr top (cons full-topic (cdr top))))
  1046.       (nconc top (list full-topic)))
  1047.     (unless (assoc topic gnus-topic-alist)
  1048.       (push (list topic) gnus-topic-alist)))
  1049.   (gnus-topic-enter-dribble)
  1050.   (gnus-group-list-groups)
  1051.   (gnus-topic-goto-topic topic))
  1052.  
  1053. (defun gnus-topic-move-group (n topic &optional copyp)
  1054.   "Move the next N groups to TOPIC.
  1055. If COPYP, copy the groups instead."
  1056.   (interactive
  1057.    (list current-prefix-arg
  1058.      (completing-read "Move to topic: " gnus-topic-alist nil t)))
  1059.   (let ((groups (gnus-group-process-prefix n))
  1060.     (topicl (assoc topic gnus-topic-alist))
  1061.     (start-group (progn (forward-line 1) (gnus-group-group-name)))
  1062.     (start-topic (gnus-group-topic-name))
  1063.     entry)
  1064.     (mapcar
  1065.      (lambda (g)
  1066.        (gnus-group-remove-mark g)
  1067.        (when (and
  1068.           (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
  1069.           (not copyp))
  1070.      (setcdr entry (gnus-delete-first g (cdr entry))))
  1071.        (nconc topicl (list g)))
  1072.      groups)
  1073.     (gnus-topic-enter-dribble)
  1074.     (if start-group
  1075.     (gnus-group-goto-group start-group)
  1076.       (gnus-topic-goto-topic start-topic))
  1077.     (gnus-group-list-groups)))
  1078.  
  1079. (defun gnus-topic-remove-group (&optional arg)
  1080.   "Remove the current group from the topic."
  1081.   (interactive "P")
  1082.   (gnus-group-iterate arg
  1083.     (lambda (group)
  1084.       (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
  1085.         (buffer-read-only nil))
  1086.     (when (and topicl group)
  1087.       (gnus-delete-line)
  1088.       (gnus-delete-first group topicl))
  1089.     (gnus-topic-update-topic)
  1090.     (gnus-group-position-point)))))
  1091.  
  1092. (defun gnus-topic-copy-group (n topic)
  1093.   "Copy the current group to a topic."
  1094.   (interactive
  1095.    (list current-prefix-arg
  1096.      (completing-read "Copy to topic: " gnus-topic-alist nil t)))
  1097.   (gnus-topic-move-group n topic t))
  1098.  
  1099. (defun gnus-topic-kill-group (&optional n discard)
  1100.   "Kill the next N groups."
  1101.   (interactive "P")
  1102.   (if (gnus-group-topic-p)
  1103.       (let ((topic (gnus-group-topic-name)))
  1104.     (push (cons
  1105.            (gnus-topic-find-topology topic)
  1106.            (assoc topic gnus-topic-alist))
  1107.           gnus-topic-killed-topics)
  1108.     (gnus-topic-remove-topic nil t)
  1109.     (gnus-topic-find-topology topic nil nil gnus-topic-topology)
  1110.     (gnus-topic-enter-dribble))
  1111.     (gnus-group-kill-group n discard)
  1112.     (gnus-topic-update-topic)))
  1113.  
  1114. (defun gnus-topic-yank-group (&optional arg)
  1115.   "Yank the last topic."
  1116.   (interactive "p")
  1117.   (if gnus-topic-killed-topics
  1118.       (let* ((previous
  1119.           (or (gnus-group-topic-name)
  1120.           (gnus-topic-next-topic (gnus-current-topic))))
  1121.          (data (pop gnus-topic-killed-topics))
  1122.          (alist (cdr data))
  1123.          (item (cdar data)))
  1124.     (push alist gnus-topic-alist)
  1125.     (gnus-topic-create-topic
  1126.      (caar item) (gnus-topic-parent-topic previous) previous
  1127.      item)
  1128.     (gnus-topic-enter-dribble)
  1129.     (gnus-topic-goto-topic (caar item)))
  1130.     (let* ((prev (gnus-group-group-name))
  1131.        (gnus-topic-inhibit-change-level t)
  1132.        (gnus-group-indentation
  1133.         (make-string
  1134.          (* gnus-topic-indent-level
  1135.         (or (save-excursion
  1136.               (gnus-topic-goto-topic (gnus-current-topic))
  1137.               (gnus-group-topic-level))
  1138.             0))
  1139.          ? ))
  1140.        yanked alist)
  1141.       ;; We first yank the groups the normal way...
  1142.       (setq yanked (gnus-group-yank-group arg))
  1143.       ;; Then we enter the yanked groups into the topics they belong
  1144.       ;; to.
  1145.       (setq alist (assoc (save-excursion
  1146.                (forward-line -1)
  1147.                (gnus-current-topic))
  1148.              gnus-topic-alist))
  1149.       (when (stringp yanked)
  1150.     (setq yanked (list yanked)))
  1151.       (if (not prev)
  1152.       (nconc alist yanked)
  1153.     (if (not (cdr alist))
  1154.         (setcdr alist (nconc yanked (cdr alist)))
  1155.       (while (cdr alist)
  1156.         (when (equal (cadr alist) prev)
  1157.           (setcdr alist (nconc yanked (cdr alist)))
  1158.           (setq alist nil))
  1159.         (setq alist (cdr alist))))))
  1160.     (gnus-topic-update-topic)))
  1161.  
  1162. (defun gnus-topic-hide-topic ()
  1163.   "Hide the current topic."
  1164.   (interactive)
  1165.   (when (gnus-current-topic)
  1166.     (gnus-topic-goto-topic (gnus-current-topic))
  1167.     (gnus-topic-remove-topic nil nil 'hidden)))
  1168.  
  1169. (defun gnus-topic-show-topic ()
  1170.   "Show the hidden topic."
  1171.   (interactive)
  1172.   (when (gnus-group-topic-p)
  1173.     (gnus-topic-remove-topic t nil 'shown)))
  1174.  
  1175. (defun gnus-topic-mark-topic (topic &optional unmark)
  1176.   "Mark all groups in the topic with the process mark."
  1177.   (interactive (list (gnus-group-topic-name)))
  1178.   (if (not topic)
  1179.       (call-interactively 'gnus-group-mark-group)
  1180.     (save-excursion
  1181.       (let ((groups (gnus-topic-find-groups topic 9 t)))
  1182.     (while groups
  1183.       (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
  1184.            (gnus-info-group (nth 2 (pop groups)))))))))
  1185.  
  1186. (defun gnus-topic-unmark-topic (topic &optional unmark)
  1187.   "Remove the process mark from all groups in the topic."
  1188.   (interactive (list (gnus-group-topic-name)))
  1189.   (if (not topic)
  1190.       (call-interactively 'gnus-group-unmark-group)
  1191.     (gnus-topic-mark-topic topic t)))
  1192.  
  1193. (defun gnus-topic-get-new-news-this-topic (&optional n)
  1194.   "Check for new news in the current topic."
  1195.   (interactive "P")
  1196.   (if (not (gnus-group-topic-p))
  1197.       (gnus-group-get-new-news-this-group n)
  1198.     (gnus-topic-mark-topic (gnus-group-topic-name))
  1199.     (gnus-group-get-new-news-this-group)))
  1200.  
  1201. (defun gnus-topic-move-matching (regexp topic &optional copyp)
  1202.   "Move all groups that match REGEXP to some topic."
  1203.   (interactive
  1204.    (let (topic)
  1205.      (nreverse
  1206.       (list
  1207.        (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
  1208.        (read-string (format "Move to %s (regexp): " topic))))))
  1209.   (gnus-group-mark-regexp regexp)
  1210.   (gnus-topic-move-group nil topic copyp))
  1211.  
  1212. (defun gnus-topic-copy-matching (regexp topic &optional copyp)
  1213.   "Copy all groups that match REGEXP to some topic."
  1214.   (interactive
  1215.    (let (topic)
  1216.      (nreverse
  1217.       (list
  1218.        (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
  1219.        (read-string (format "Copy to %s (regexp): " topic))))))
  1220.   (gnus-topic-move-matching regexp topic t))
  1221.  
  1222. (defun gnus-topic-delete (topic)
  1223.   "Delete a topic."
  1224.   (interactive (list (gnus-group-topic-name)))
  1225.   (unless topic
  1226.     (error "No topic to be deleted"))
  1227.   (let ((entry (assoc topic gnus-topic-alist))
  1228.     (buffer-read-only nil))
  1229.     (when (cdr entry)
  1230.       (error "Topic not empty"))
  1231.     ;; Delete if visible.
  1232.     (when (gnus-topic-goto-topic topic)
  1233.       (gnus-delete-line))
  1234.     ;; Remove from alist.
  1235.     (setq gnus-topic-alist (delq entry gnus-topic-alist))
  1236.     ;; Remove from topology.
  1237.     (gnus-topic-find-topology topic nil nil 'delete)
  1238.     (gnus-dribble-touch)))
  1239.  
  1240. (defun gnus-topic-rename (old-name new-name)
  1241.   "Rename a topic."
  1242.   (interactive
  1243.    (let ((topic (gnus-current-topic)))
  1244.      (list topic
  1245.        (read-string (format "Rename %s to: " topic)))))
  1246.   (let ((top (gnus-topic-find-topology old-name))
  1247.     (entry (assoc old-name gnus-topic-alist)))
  1248.     (when top
  1249.       (setcar (cadr top) new-name))
  1250.     (when entry
  1251.       (setcar entry new-name))
  1252.     (forward-line -1)
  1253.     (gnus-dribble-touch)
  1254.     (gnus-group-list-groups)))
  1255.  
  1256. (defun gnus-topic-indent (&optional unindent)
  1257.   "Indent a topic -- make it a sub-topic of the previous topic.
  1258. If UNINDENT, remove an indentation."
  1259.   (interactive "P")
  1260.   (if unindent
  1261.       (gnus-topic-unindent)
  1262.     (let* ((topic (gnus-current-topic))
  1263.        (parent (gnus-topic-previous-topic topic))
  1264.        (buffer-read-only nil))
  1265.       (unless parent
  1266.     (error "Nothing to indent %s into" topic))
  1267.       (when topic
  1268.     (gnus-topic-goto-topic topic)
  1269.     (gnus-topic-kill-group)
  1270.     (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
  1271.     (gnus-topic-create-topic
  1272.      topic parent nil (cdaar gnus-topic-killed-topics))
  1273.     (pop gnus-topic-killed-topics)
  1274.     (or (gnus-topic-goto-topic topic)
  1275.         (gnus-topic-goto-topic parent))))))
  1276.  
  1277. (defun gnus-topic-unindent ()
  1278.   "Unindent a topic."
  1279.   (interactive)
  1280.   (let* ((topic (gnus-current-topic))
  1281.      (parent (gnus-topic-parent-topic topic))
  1282.      (grandparent (gnus-topic-parent-topic parent)))
  1283.     (unless grandparent
  1284.       (error "Nothing to indent %s into" topic))
  1285.     (when topic
  1286.       (gnus-topic-goto-topic topic)
  1287.       (gnus-topic-kill-group)
  1288.       (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
  1289.       (gnus-topic-create-topic
  1290.        topic grandparent (gnus-topic-next-topic parent)
  1291.        (cdaar gnus-topic-killed-topics))
  1292.       (pop gnus-topic-killed-topics)
  1293.       (gnus-topic-goto-topic topic))))
  1294.  
  1295. (defun gnus-topic-list-active (&optional force)
  1296.   "List all groups that Gnus knows about in a topicsified fashion.
  1297. If FORCE, always re-read the active file."
  1298.   (interactive "P")
  1299.   (when force
  1300.     (gnus-get-killed-groups))
  1301.   (gnus-topic-grok-active force)
  1302.   (let ((gnus-topic-topology gnus-topic-active-topology)
  1303.     (gnus-topic-alist gnus-topic-active-alist)
  1304.     gnus-killed-list gnus-zombie-list)
  1305.     (gnus-group-list-groups 9 nil 1)))
  1306.  
  1307. (defun gnus-topic-toggle-display-empty-topics ()
  1308.   "Show/hide topics that have no unread articles."
  1309.   (interactive)
  1310.   (setq gnus-topic-display-empty-topics
  1311.     (not gnus-topic-display-empty-topics))
  1312.   (gnus-group-list-groups)
  1313.   (message "%s empty topics"
  1314.        (if gnus-topic-display-empty-topics
  1315.            "Showing" "Hiding")))
  1316.  
  1317. ;;; Topic sorting functions
  1318.  
  1319. (defun gnus-topic-edit-parameters (group)
  1320.   "Edit the group parameters of GROUP.
  1321. If performed on a topic, edit the topic parameters instead."
  1322.   (interactive (list (gnus-group-group-name)))
  1323.   (if group
  1324.       (gnus-group-edit-group-parameters group)
  1325.     (if (not (gnus-group-topic-p))
  1326.     (error "Nothing to edit on the current line")
  1327.       (let ((topic (gnus-group-topic-name)))
  1328.     (gnus-edit-form
  1329.      (gnus-topic-parameters topic)
  1330.      (format "Editing the topic parameters for `%s'."
  1331.          (or group topic))
  1332.      `(lambda (form)
  1333.         (gnus-topic-set-parameters ,topic form)))))))
  1334.  
  1335. (defun gnus-group-sort-topic (func reverse)
  1336.   "Sort groups in the topics according to FUNC and REVERSE."
  1337.   (let ((alist gnus-topic-alist))
  1338.     (while alist
  1339.       ;; !!!Sometimes nil elements sneak into the alist,
  1340.       ;; for some reason or other.
  1341.       (setcar alist (delq nil (car alist)))
  1342.       (setcar alist (delete "dummy.group" (car alist)))
  1343.       (gnus-topic-sort-topic (pop alist) func reverse))))
  1344.  
  1345. (defun gnus-topic-sort-topic (topic func reverse)
  1346.   ;; Each topic only lists the name of the group, while
  1347.   ;; the sort predicates expect group infos as inputs.
  1348.   ;; So we first transform the group names into infos,
  1349.   ;; then sort, and then transform back into group names.
  1350.   (setcdr
  1351.    topic
  1352.    (mapcar
  1353.     (lambda (info) (gnus-info-group info))
  1354.     (sort
  1355.      (mapcar
  1356.       (lambda (group) (gnus-get-info group))
  1357.       (cdr topic))
  1358.      func)))
  1359.   ;; Do the reversal, if necessary.
  1360.   (when reverse
  1361.     (setcdr topic (nreverse (cdr topic)))))
  1362.  
  1363. (defun gnus-topic-sort-groups (func &optional reverse)
  1364.   "Sort the current topic according to FUNC.
  1365. If REVERSE, reverse the sorting order."
  1366.   (interactive (list gnus-group-sort-function current-prefix-arg))
  1367.   (let ((topic (assoc (gnus-current-topic) gnus-topic-alist)))
  1368.     (gnus-topic-sort-topic
  1369.      topic (gnus-make-sort-function func) reverse)
  1370.     (gnus-group-list-groups)))
  1371.  
  1372. (defun gnus-topic-sort-groups-by-alphabet (&optional reverse)
  1373.   "Sort the current topic alphabetically by group name.
  1374. If REVERSE, sort in reverse order."
  1375.   (interactive "P")
  1376.   (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse))
  1377.  
  1378. (defun gnus-topic-sort-groups-by-unread (&optional reverse)
  1379.   "Sort the current topic by number of unread articles.
  1380. If REVERSE, sort in reverse order."
  1381.   (interactive "P")
  1382.   (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse))
  1383.  
  1384. (defun gnus-topic-sort-groups-by-level (&optional reverse)
  1385.   "Sort the current topic by group level.
  1386. If REVERSE, sort in reverse order."
  1387.   (interactive "P")
  1388.   (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse))
  1389.  
  1390. (defun gnus-topic-sort-groups-by-score (&optional reverse)
  1391.   "Sort the current topic by group score.
  1392. If REVERSE, sort in reverse order."
  1393.   (interactive "P")
  1394.   (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse))
  1395.  
  1396. (defun gnus-topic-sort-groups-by-rank (&optional reverse)
  1397.   "Sort the current topic by group rank.
  1398. If REVERSE, sort in reverse order."
  1399.   (interactive "P")
  1400.   (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse))
  1401.  
  1402. (defun gnus-topic-sort-groups-by-method (&optional reverse)
  1403.   "Sort the current topic alphabetically by backend name.
  1404. If REVERSE, sort in reverse order."
  1405.   (interactive "P")
  1406.   (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
  1407.  
  1408. (provide 'gnus-topic)
  1409.  
  1410. ;;; gnus-topic.el ends here
  1411.